home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Tech Arsenal 1
/
Tech Arsenal (Arsenal Computer).ISO
/
tek-02
/
design60.zip
/
IBMLIB2.INC
< prev
next >
Wrap
Text File
|
1991-05-13
|
8KB
|
281 lines
procedure shrink(v1,v2:String80);
var
ch : char;
ndeleted : real;
s : real;
begin
ndeleted := 0;
make_window(10,10,70,15,f,b,True);
s := filesize(d);
writeln;
write(' Do you want to dump deleted records? (Y/N) ');
if not yes then
begin
remove_window;
exit
end else
begin
seek(d,0);
assign(tempfile,scratch);
rewrite(tempfile);
gotoxy(5,3);
write('Reading record');
while not eof(d) do
begin
read(d,rec);
gotoxy(21,3);
write(filepos(d):5);
with rec do
if not empty then
write(tempfile,rec) else
ndeleted := ndeleted + 1;
end;
close(d);
close(tempfile);
erase(d);
rename(tempfile,filename);
reset(d);
display_size;
writeln;
writeln(' Number of records deleted =',ndeleted:5:0);
write(' Press any key...');
display_size;
clock;
Ch := ReadKey;
remove_window
end;
end;
procedure backup;
var
disk, ch : char;
destfile : file of recs;
recnum : Integer;
add : boolean;
begin
make_window(10,5,70,20,f,b,True);
write(' Copy <F>rom floppy, or <T>o floppy? ');
repeat
Ch := ReadKey;
ch := upcase(ch);
until ch in ['F','T'];
writeln;
if ch = 'T' then
begin
writeln;
write(' Destination drive for data? (A or B) ');
repeat
Disk := UpCase(ReadKey);
until disk in ['A','B'];
write(disk+':'); writeln;
write(' Insert disk ',disk,': and press any key or ESC to abort...');
Ch := ReadKey;
writeln;
if ch <> ESC then
begin
clrscr;
write(' Copying Database ');
recnum := 1;
seek(d,recnum - 1);
assign(destfile,disk+':'+filename);
rewrite(destfile);
clrscr;
gotoxy(2,3); write('Copying Record');
while not eof(d) do
begin
gotoxy(17,3);
write(recnum:4);
read(d,rec);
write(destfile,rec);
recnum := succ(recnum);
if free(disk) <= 1000 then
begin
close(destfile);
writeln;
beep;
writeln(' Diskette full!');
writeln(' Insert next diskette and press any key,');
write(' or ESC to abort...');
Ch := ReadKey;
if ch = ESC then
begin
remove_window;
exit
end;
clrscr;
rewrite(destfile);
gotoxy(2,3); write('Copying Record');
end;
end;
close(destfile);
end;
end else
begin
recnum := 0;
clrscr;
writeln(' Do you want to <A>dd to present database, or');
write(' start with a <N>ew database? (A/N) ');
repeat
Ch := ReadKey;
ch := upcase(ch);
until ch in ['A','N'];
if ch = 'A' then
begin
add := true;
write('Add')
end else
begin
add := false;
writeln('New');
writeln;
if exist(filename) then
begin
beep;
write('WARNING! This will erase the database. '+
'Are you sure? (Y/N) ');
if not yyes then
begin
remove_window;
exit
end;
end; { Exist }
end;
writeln;
write(' Disk to copy from? (A or B) ');
Disk := UpCase(ReadKey); write(disk,':'); writeln;
writeln(' Insert each disk in sequence to copy. Make sure');
writeln(' you don''t insert the same one twice.');
writeln(' Insert first diskette and press any key, or ESC');
writeln(' to abort...');
if not add then
begin
close(d);
rewrite(d);
recnum := 0;
end else
begin
recnum := filesize(d);
seek(d,recnum) { Go to end of file to add }
end;
repeat
Ch := ReadKey;
if not exist(disk+':'+filename) then
repeat
beep;
writeln;
writeln(' File not found on ',disk+':');
writeln(' Insert new disk or press ESC to abort.');
Ch := ReadKey;
until (ch = ESC) or exist(disk+':'+filename);
if ch = ESC then
begin
writeln;
write(' Do you want to sort the new file? (Y/N) ');
if yyes then
begin
sort;
reset(d)
end;
remove_window;
display_size;
exit
end;
assign(destfile,disk+':'+filename);
reset(destfile);
clrscr;
gotoxy(2,3); write('Copying Record');
while not eof(destfile) do
begin
recnum := succ(recnum);
gotoxy(17,3);
write(recnum:4);
read(destfile,rec);
write(d,rec)
end;
close(destfile);
clrscr;
Writeln(' Insert next diskette and press any, key or ESC');
writeln(' to abort...');
until ch = ESC;
close(d);
reset(d);
end;
display_size;
remove_window
end;
{ -------------------------------------------------------- }
procedure pad(var line:String80; lnth:Integer);
begin
line := line + spaces(lnth-length(line));
end;
{ -------------------------------------------------------- }
procedure remove_spaces(var s:String80);
var
temp : String80;
i, n : Integer;
begin
n := length(s);
temp := '';
for i := 1 to n do
if s[i] <> #32 then
temp := concat(temp,s[i]);
s := temp
end;
function match(str1,str2:String80):boolean;
var
n : Integer;
temp : String80;
tempmatch : boolean;
ch : char;
begin
str1 := uppercase(str1);
str2 := uppercase(str2);
remove_spaces(str1);
remove_spaces(str2);
n := length(str1);
if (pos('<',str1) > 0) or
(pos('>',str1) > 0) then
n := pred(n);
if (pos('=',str1) > 0) then
n := pred(n);
temp := copy(str2,1,n);
tempmatch := str1 = temp;
if blank(str1) then
tempmatch := true;
if (pos('>=',str1) = 1) and not tempmatch then
begin
str1 := copy(str1,3,n);
if str1 <= copy(temp,1,n) then tempmatch := true;
end;
if (pos('<=',str1) = 1) and not tempmatch then
begin
str1 := copy(str1,3,n);
if str1 >= copy(temp,1,n) then tempmatch := true;
end;
if (pos('>',str1) = 1) and not tempmatch then
begin
str1 := copy(str1,2,n);
if str1 < copy(temp,1,n) then tempmatch := true;
end;
if (pos('<',str1) = 1) and not tempmatch then
begin
str1 := copy(str1,2,n);
if str1 > copy(temp,1,n) then tempmatch := true;
end;
match := tempmatch;
end;
function abort:boolean;
begin
make_window(20,10,60,13,f,b,True);
write(' Abort printing? (Y/N) ');
abort := yyes;
remove_window
end;